TestDrive Windows 1993 Fall/TestDrive Windows 1993 Fall.iso/dbase/samples/employee.prg

Text File | 1993-03-09 | 10.9 KB | 333 lines

******************************************************************************
* PROGRAM NAME: EMPLOYEE.PRG
*               EMPLOYEE DATABASE SCREEN
*               SAMPLE BUSINESS APPLICATION PROGRAM
* LAST CHANGED: 09/25/89 09:26AM
* WRITTEN BY:   Borland International Inc.
******************************************************************************
*
*       FILES USED:
*       Database        = Employee.dbf  (Employee personnel file)
*       Index file      = Employee.mdx
*           TAG: Names  = lastname+firstname+initial  <= Master index
*           TAG: Dept   = department+lastname+firstname+initial
*           TAG: Status = department+STR(salary,8,2)
*           TAG: Years  = STR(yrs_exper,4,1)
*           TAG: Emp_id = emp_id
*       External procedure file used = Library.prg
******************************************************************************

* Main procedure
PROCEDURE Employee

   * Link to external procedure file of "tool" procedures
   SET PROCEDURE TO Library

   * Set up database environment
   DO Set_env

   SET COLOR TO &c_standard.

   * Declare variables used:
   * Database memory variables
   STORE ""  TO lastname, firstname, initial, address1, address2, city, state
   STORE ""  TO zip, phone, emp_id, specialty, degree, awards, comments
   STORE ""  TO department, title
   STORE  0  TO laborgrade, yrs_exper, salary, rate
   STORE .T. TO exempt, full_time
   date_hired = {  /  /  }

   * Miscellaneous variables - used to pass parameters to Library
   STORE "EMPLOYEE" TO dbf,mlist    && Standard report and mail list available
   STORE "" TO cust_rpt             && Custom report(s) are available
   key      = "m->lastname+m->firstname"
   key1     = "m->lastname"
   key2     = "m->firstname"
   key3     = "NONE"
   keyname1 = "Lastname:"
   keyname2 = "Firstname:"
   keyname3 = ""
   list_flds  = "LASTNAME, FIRSTNAME, DEPARTMENT, PHONE"

   DO EmployeeM


   RELEASE gl_MainMenu                  && Allow Rest_env to reset the
   DO Rest_env                          && environment back.
   ON ERROR
   ON KEY LABEL F1
   CLEAR ALL
   CLOSE ALL
   CLEAR

RETURN

PROCEDURE EmployeeM
   * Open database files and choose active indexes
   SELECT 1
   USE Employee ORDER Names
   GO TOP
   * Used for area code lookup
   USE Codes ORDER City IN 2

   * Load initial record from database into memory variables
   record_num = RECNO()
   DO Load_fld

   * Show data screen
   SET COLOR TO &c_standard.
   CLEAR
   DO Dstatus
   DO Backgrnd
   DO Show_data

   * Define popup menus
   DO Bar_def

   * Activate main popup menu - execute user choices
   SET COLOR TO &c_popup.
   ACTIVATE POPUP main_mnu
   DO Sub_ret
   *
RETURN
*========================= end of main procedure =============================

*  UTILITY PROCEDURES (Proprietary to Employee.prg)

PROCEDURE Filter
  * Filter (group) data into subset
  * Select subset to set up filter condition (Y=turn on, N=abort selection,
  * T=turn off). If filter is already on, set default choice to T, show
  * window. If filter is not on, set default choice to Y, show window.
  choice = IIF(filters_on,"T","Y")
  DO Filt_ans
  IF choice = "Y"
    * Start process of choosing filter condition
    STORE SPACE(15) TO department, title
    STORE SPACE(11) TO specialty
    STORE SPACE(3)  TO degree
    ACTIVATE WINDOW alert
       @   0,0 SAY "--------- ENTER FILTER CONDITION --------"
       @   1,1 SAY "DEPARTMENT: " GET m->department FUNCTION "!"
       @   2,1 SAY "TITLE       " GET m->title      FUNCTION "!"
       @   3,1 SAY "SPECIALTY   " GET m->specialty  FUNCTION "!"
       @   4,1 SAY "DEGREE      " GET m->degree     FUNCTION "!"
       @   5,1 SAY "Enter one or more conditions"
       READ
    DEACTIVATE WINDOW alert
    * Initialize filter variable to null (empty)
    subset = ""
    * Process user's entries to build filter condition
    subset = subset + IIF("" <> TRIM(m->department), ;
       [department = TRIM("&department.") .AND.], "")
    subset = subset + IIF("" <> TRIM(m->title), ;
       [title = TRIM("&title.") .AND.], "")
    subset = subset + IIF("" <> TRIM(m->specialty), ;
       [specialty = TRIM("&specialty.") .AND.], "")
    subset = subset + IIF("" <> TRIM(m->degree), ;
       [degree = TRIM("°ree.") .AND.], "")
    *
    * Check whether data entered into subset string
    IF "" = TRIM(subset)
       DO Warnbell
       filters_on = .F.
    ELSE
       * If string is not empty, truncate the .AND. from end of subset string
       subset = SUBSTR(subset,1,LEN(subset)-6)
       * Filter on entered filter string condition
       SET FILTER TO &subset.
       * Activate filter by moving record pointer
       GO TOP
       * Check whether filter condition matches any records (no match=EOF)
       filters_on = .NOT. EOF()
       IF .NOT. filters_on
          * Turn off filter if no matching records found
          DO Warnbell
          DO Show_msg WITH "No Employee records match the filter condition"
          SET FILTER TO
          GO record_num
       ENDIF
    ENDIF
  ELSE
     IF choice = "T"
        * If user selects "T", turn off filter
        SET FILTER TO
        filters_on = .F.
     ENDIF
  ENDIF
RETURN

PROCEDURE Indexer
   * Create/rebuild indexes
   INDEX ON department+lastname+firstname+initial TAG Dept
   INDEX ON department+STR(salary,8,2)            TAG Status
   INDEX ON STR(yrs_exper,4,1)                    TAG Years
   INDEX ON emp_id                                TAG Emp_id
   INDEX ON lastname+firstname+initial            TAG Names
   GO TOP
RETURN

PROCEDURE Init_fld
    * Initialize memory variable values for data entry
    initial    = " "
    STORE SPACE(20) TO address1, address2
    STORE SPACE(10) TO firstname, zip
    STORE SPACE(15) TO lastname, department, title, awards
    STORE SPACE(11) TO emp_id, specialty
    STORE 0 TO laborgrade, yrs_exper, salary, rate
    STORE .T. TO exempt, full_time
    city       = SPACE(14)
    state      = SPACE(2)
    phone      = SPACE(13)
    degree     = SPACE(3)
    comments   = SPACE(40)
    date_hired = {  /  /  }
RETURN

PROCEDURE Load_fld
   * Load field values from Employee database record into memory variables
   lastname   = lastname
   firstname  = firstname
   initial    = initial
   emp_id     = emp_id
   address1   = address1
   address2   = address2
   city       = city
   state      = state
   zip        = zip
   phone      = phone
   department = department
   title      = title
   laborgrade = laborgrade
   exempt     = exempt
   full_time  = full_time
   date_hired = date_hired
   specialty  = specialty
   yrs_exper  = yrs_exper
   degree     = degree
   salary     = salary
   rate       = rate
   awards     = awards
   comments   = comments
RETURN

PROCEDURE Repl_fld
   * Replace database fields with values of current memory variables
   REPLACE emp_id WITH m->emp_id, lastname WITH m->lastname, ;
           firstname WITH m->firstname, initial WITH m->initial, ;
           address1 WITH m->address1, address2 WITH m->address2, ;
           city  WITH m->city, state WITH m->state, zip WITH m->zip, ;
           phone WITH m->phone, department WITH m->department
   REPLACE title WITH m->title, laborgrade WITH m->laborgrade, ;
           exempt WITH m->exempt, full_time WITH m->full_time, ;
           date_hired WITH m->date_hired, specialty WITH m->specialty, ;
           yrs_exper WITH m->yrs_exper, degree WITH m->degree, ;
           salary WITH m->salary, rate WITH m->rate, ;
           awards WITH m->awards, comments WITH m->comments
RETURN

PROCEDURE Backgrnd
   * Display background screen
   * Draw and fill in boxes
   @  1,18 TO   3,41 DOUBLE COLOR &c_blue.
   @  4, 1 TO   6,56 DOUBLE COLOR &c_red.
   @  2,19 FILL TO  2,40    COLOR &c_blue.
   @  4, 2 FILL TO 21,55    COLOR &c_red.
   @ 11, 1 TO  11,56        COLOR &c_red.
   @  7, 1 TO  22,56        COLOR &c_red.
   SET COLOR TO &c_data.
   @  2,20 SAY "EMPLOYEE  DATABASE"
   @  5, 3 SAY "LAST NAME:"
   @  5,32 SAY "FIRST:"
   @  5,53 SAY "."
   @  8, 3 SAY "ADDRESS:"
   @  9, 3 SAY "CITY:"
   @  9,32 SAY "STATE:"
   @ 10, 3 SAY "ZIP:"
   @ 10,32 SAY "PHONE:"
   @ 12, 3 SAY "DEPARTMENT:"
   @ 12,32 SAY "TITLE:"
   @ 13,32 SAY "SPECIALTY:"
   @ 14, 3 SAY "EMPLOYEE NO:"
   @ 14,32 SAY "HIRE DATE:"
   @ 15,32 SAY "FULL TIME:"
   @ 16,32 SAY "EXEMPT:"
   @ 17,32 SAY "LABOR GRADE:"
   @ 18, 3 SAY "SALARY: $"
   @ 18,32 SAY "COMMISSION RATE:"
   @ 18,54 SAY "%"
   @ 19, 3 SAY "DEGREE:"
   @ 19,32 SAY "YEARS EXPERIENCE:"
   @ 20, 3 SAY "AWARDS:"
   @ 21, 3 SAY "COMMENTS:"
   SET COLOR TO &c_standard.
RETURN

PROCEDURE Show_data
   * Display data
   SET COLOR TO &c_fields.
   @  5,14 SAY lastname
   @  5,39 SAY firstname
   @  5,52 SAY initial
   @  8,12 SAY address1
   @  8,34 SAY address2
   @  9,12 SAY city
   @  9,39 SAY state
   @ 10,12 SAY zip
   @ 10,39 SAY phone
   @ 12,16 SAY department
   @ 12,39 SAY title
   @ 13,43 SAY specialty
   @ 14,16 SAY emp_id
   @ 14,43 SAY date_hired
   @ 15,43 SAY full_time  PICTURE  "Y"
   @ 16,43 SAY exempt     PICTURE  "Y"
   @ 17,45 SAY laborgrade PICTURE  "9"
   @ 18,14 SAY salary     PICTURE  "999,999.99"
   @ 18,50 SAY rate       PICTURE  "99.9"
   @ 19,14 SAY degree
   @ 19,50 SAY yrs_exper  PICTURE  "99.9"
   @ 20,14 SAY awards
   @ 21,14 SAY comments
   SET COLOR TO &c_standard.
   ON KEY LABEL F9 DO Findcode WITH m->city
RETURN

PROCEDURE Get_data
   * Display data for entry
   SET COLOR TO &c_data.
   @  5,14 GET m->lastname   PICTURE "!XXXXXXXXXXXXXX" ;
           MESSAGE "Enter employee last name"
   @  5,39 GET m->firstname  PICTURE "!XXXXXXXXX"
   @  5,52 GET m->initial    PICTURE "!"
   @  8,12 GET m->address1
   @  8,34 GET m->address2
   @  9,12 GET m->city       PICTURE "!XXXXXXXXXXXXX"
   @  9,39 GET m->state      PICTURE "!!"
   @ 10,12 GET m->zip
   @ 10,39 GET m->phone      PICTURE  "[phone]"
   @ 12,16 GET m->department PICTURE "@M SALES, EXECUTIVE" ;
           MESSAGE "Press spacebar for Department options"
   @ 12,39 GET m->title      FUNCTION "!"
   @ 13,43 GET m->specialty  FUNCTION "!"
   @ 14,16 GET m->emp_id     PICTURE  "999-99-9999"
   @ 14,43 GET m->date_hired FUNCTION "D"
   @ 15,43 GET m->full_time  PICTURE  "Y" ;
           WHEN TRIM(m->department) <> "EXECUTIVE"
   @ 16,43 GET m->exempt     PICTURE  "Y" ;
           WHEN TRIM(m->department) <> "EXECUTIVE"
   @ 17,45 GET m->laborgrade PICTURE  "9"
   @ 18,14 GET m->salary     PICTURE  "999,999.99"
   @ 18,50 GET m->rate       PICTURE  "99.9" ;
           WHEN TRIM(m->department) <> "EXECUTIVE"
   @ 19,14 GET m->degree     PICTURE  "!!!"
   @ 19,50 GET m->yrs_exper  PICTURE  "99.9"
   @ 20,14 GET m->awards     FUNCTION "!"
   @ 21,14 GET m->comments
   SET COLOR TO &c_standard.
   ON KEY LABEL F9 DO Findcode WITH m->city
RETURN

**********************************  END OF EMPLOYEE.PRG  *********************